;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp; Patch-File: Yes -*-
;;;
;;; *************************************************************************
;;; Copyright (c) 1985 Xerox Corporation.  All rights reserved.
;;;
;;; Use and copying of this software and preparation of derivative works
;;; based upon this software are permitted.  Any distribution of this
;;; software or derivative works must comply with all applicable United
;;; States export control laws.
;;; 
;;; This software is made available AS IS, and Xerox Corporation makes no
;;; warranty about the software, its performance or its conformity to any
;;; specification.
;;; 
;;; Any person obtaining a copy of this software is requested to send their
;;; name and post office or electronic mail address to:
;;;   CommonLoops Coordinator
;;;   Xerox Artifical Intelligence Systems
;;;   2400 Hanover St.
;;;   Palo Alto, CA 94303
;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
;;;
;;; Suggestions, comments and requests for improvements are also welcome.
;;; *************************************************************************
;;;

(in-package 'pcl)

(eval-when (compile load eval)
  (setf (symbol-function 'expand-defmeth)
	(symbol-function 'real-expand-defmeth)))

(eval-when (load)
  (clrhash *discriminator-name-hash-table*)
  (fix-early-defmeths)
  (setq *error-when-defining-method-on-existing-function* t))

(eval-when (compile load eval)
  (setq *real-methods-exist-p* t))

  ;;   
;;;;;; Pending defmeths which I couldn't do before.
  ;;


(eval-when (load eval)
  (setf (discriminator-named 'print-instance) ())
  (make-specializable 'print-instance :arglist '(instance stream depth)))

(defmeth print-instance ((instance object) stream depth)
  (let ((length (if (numberp *print-length*) (* *print-length* 2) nil)))
    (format stream "#S(~S" (class-name (class-of instance)))
    (iterate ((slot-or-value in (all-slots instance))
	      (slotp = t (not slotp)))
      (when (numberp length)
	(cond ((<= length 0) (format stream " ...") (return ()))
	      (t (decf length))))
      (princ " " stream)
      (let ((*print-level* (cond ((null *print-level*) ())
				 (slotp 1)
				 (t (- *print-level* depth)))))
	(if (and *print-level* (<= *print-level* 0))
	    (princ "#" stream)
	    (prin1 slot-or-value stream))))
    (princ ")" stream)))

(defmeth print-instance ((class essential-class) stream depth)
  (named-object-print-function class stream depth))

(eval-when (load)

(define-meta-class essential-class (lambda (x) (%instance-ref x 0)))

(defmeth class-slots ((class essential-class))
  ())

(defmeth make-instance ((class essential-class))
  (let ((primitive-instance
	  (%make-instance (class-named 'essential-class)
			  (1+ (length (class-slots class))))))
    (setf (%instance-ref primitive-instance 0) class)
    primitive-instance))

(defmeth get-slot-using-class ((class essential-class) object slot-name)
  (let ((pos (position slot-name (class-slots class) :key #'slotd-name)))
    (if pos
	(%instance-ref object (1+ pos))
	(slot-missing ;class
	  object slot-name))))

(defmeth put-slot-using-class ((class essential-class)
			       object
			       slot-name
			       new-value)
  (let ((pos (position slot-name (class-slots class) :key #'slotd-name)))
    (if pos
	(setf (%instance-ref object (1+ pos)) new-value)
	(slot-missing ;class
		      object slot-name))))

(defmeth optimize-get-slot ((method essential-method)
			    (class essential-class)
			    form)
  form)

(defmeth optimize-setf-of-get-slot ((method essential-method)
				    (class essential-class)
				    form)
  form)

(defmeth make-slotd ((class essential-class) &rest keywords-and-options)
  (apply #'make-slotd--essential-class keywords-and-options))

(defmeth add-named-class ((proto-class essential-class) name
			  local-supers
			  local-slot-slotds
			  extra)
  ;; First find out if there is already a class with this name.
  ;; If there is, call class-for-redefinition to get the class
  ;; object to use for the new definition.  If there is no exisiting
  ;; class we just make a new instance.
  (let* ((existing (class-named name t))
	 (class (if existing
		    (class-for-redefinition existing proto-class name 
					    local-supers local-slot-slotds
					    extra)
		    (make (class-of proto-class)))))

    (setq local-supers
	  (mapcar
	    #'(lambda (ls)
		(or (class-named ls t)
		    (error "~S was specified as the name of a local-super~%~
                            for the class named ~S.  But there is no class~%~
                            class named ~S." ls name ls)))
	    local-supers))
    
    (setf (class-name class) name)
;   (setf (class-ds-options class) extra)	;This is NOT part of the
;						;standard protocol.
   
    (add-class class local-supers local-slot-slotds extra)
    
    (setf (class-named name) class)
    name))

(defmeth supers-changed ((class essential-class)
			 old-local-supers
			 old-local-slots
			 extra
			 top-p)
  (ignore old-local-supers old-local-slots top-p)
  (let ((cpl (compute-class-precedence-list class
					    (class-local-supers class))))
    (setf (class-class-precedence-list class) cpl)
;   (update-slots--class class cpl)		         ;This is NOT part of
;						         ;the essential-class
;						         ;protocol.
    (dolist (sub-class (class-direct-subclasses class))
      (supers-changed sub-class
		      (class-local-supers sub-class)
		      (class-local-slots sub-class)
		      extra
		      nil))
;   (when top-p                                          ;This is NOT part of
;     (update-method-inheritance class old-local-supers));the essential-class
; 					                 ;protocol.
    ))

(defmeth slots-changed ((class essential-class)
			old-local-slots
			extra
			top-p)
  (ignore top-p old-local-slots)
  ;; When this is called, class should have its local-supers and
  ;; local-slots slots filled in properly.
; (update-slots--class class (class-class-precedence-list class))
  (dolist (sub-class (class-direct-subclasses class))
    (slots-changed sub-class (class-local-slots sub-class) extra nil)))

(defmeth method-equal (method argument-specifiers options)
  (equal argument-specifiers (method-type-specifiers method)))

(defmeth methods-combine-p ((d essential-discriminator)) 
 nil)

)

  ;;   
;;;;;; 
  ;;   

(defmacro run-super ()
  (if (null (boundp '*current-discriminator-name*))
      (progn (warn "Using run-super outside of a defmeth~%~
                    At run time this will generate an error.")
             `(error "Using run-super outside of a defmeth."))
      (let ((type-specs (method-type-specifiers *current-method*)))
        (cond ((null type-specs)
               (warn "Using run-super inside of a default method~%~
                      At run time this will generate an error.")
               `(error "Using run-super from inside a default method."))
              (t
               `(run-super-internal
                  (load-time-eval (discriminator-named ',*current-discriminator-name*))
                  (load-time-eval (or *current-method*
                                      (find-method
                                        (discriminator-named ',*current-discriminator-name*)
                                        ',(unparse-type-specifiers *current-method*)
					()
					t)))
                  . ,(method-arglist *current-method*)))))))

(defun run-super-internal (discriminator current-method &rest args)
  (let ((type-specifiers (method-type-specifiers current-method))
        (most-specific nil)
        (most-specific-type-specifiers ())
	(dispatch-order (get-slot--class discriminator 'dispatch-order)))
    (iterate ((method in (discriminator-methods discriminator)))
      (let ((method-type-specifiers (method-type-specifiers method))
            (temp ()))
        (and (every #'(lambda (arg type-spec)
			(or (eq type-spec 't)
			    (memq type-spec
				  (get-slot--class
				    (class-of arg) 'class-precedence-list))))
                    args method-type-specifiers)
             (eql 1 (setq temp (compare-type-specifier-lists type-specifiers
                                                             method-type-specifiers
                                                             ()
                                                             args
                                                             ()
							     dispatch-order)))
             (or (null most-specific)
                 (eql 1 (setq temp (compare-type-specifier-lists
                                     method-type-specifiers
                                     most-specific-type-specifiers
                                     ()
                                     args
                                     ()
				     dispatch-order))))
             (setq most-specific method
                   most-specific-type-specifiers method-type-specifiers))))
    (if (or most-specific
            (setq most-specific (discriminator-default-method discriminator)))
        (apply (method-function most-specific) args)
        (error "no super method found"))))